home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Libris Britannia 4
/
science library(b).zip
/
science library(b)
/
PROGRAMM
/
DB_CLIPP
/
0643C.ZIP
/
PAGES.SRC
< prev
next >
Wrap
Text File
|
1986-11-18
|
7KB
|
280 lines
* pages.src
* pages procedures file
* Andrew Schulman, 12 Humboldt St., Cambridge MA 02140
* 11/16/86
procedure PAGES
parameters filename, MYTOP, DEPTH, START, SHOWPAGE, SHOWRULE
store space(10) to whichpage, phrase, otherfile
if DEPTH + START > 22 .or. START > 22 .or. SHOWPAGE > START .or. ;
SHOWRULE > START
@3,0 say "PAGES won't fit on screen or SHOWPAGE/SHOWRULE won't show"
@4,0 say "Correct example: do PAGES with 'pages.src', 1, 19, 3, 1, 2"
return
endif
if .not. file(filename)
@START,0 say "PAGES can't find " + filename
return
endif
msgline = START + DEPTH + 1
@START,0 clear to msgline-2,79
@START,0 say "Working...."
do BLINKY
* scan codes for PC keys
UP = 5
DOWN = 24
PGUP = 18
PGDN = 3
HOME = 1
ENDKEY = 6
set heading off
load curson
load cursoff
* DEMO.PRG checked to make sure these existed; your calling program should too
call cursoff
do SHOW_REV with filename, SHOWPAGE, 0
**** if you don't want to show filename, delete preceding line
use line
if len(line) > 78
@START,0 say "Please use LINE.DBF that comes with PAGES: 78 chars wide"
do BYE_BYE
return
endif
set safety off
zap
set safety on
append from &filename sdf
go bottom
do while len(trim(line)) < 1
delete
skip -1
enddo
pack
* would have like to have used append from &filename for... sdf, but that
* would kill blank lines in middle of file too!
if reccount() < 1
do WAIT_MSG with "File is empty"
do BYE_BYE
return
endif
page = 1
size = reccount() + 1 - MYTOP
p = size / DEPTH
q = int(p)
pages = iif(p - q = 0, q, q + 1)
end = iif(size < DEPTH, 1, size - DEPTH + START)
foundit = 0
didsearch = .F.
overlap = 0 && this can be changed to anything < DEPTH
if SHOWRULE > 0
@SHOWRULE,0 to SHOWRULE,78 double
endif
@msgline-1,0 to msgline-1,78 double
goto MYTOP
do while .not. eof()
thispage = "Page " + str(page,2) + " of " + str(pages,2)
do SHOW_REV with thispage, SHOWPAGE, 66
@START,0 clear to msgline-2,79
@START-1,79 && see Liskin, Adv dBase III, p.286, for reason
if recno() <> MYTOP
skip overlap + 1
endif
list off trim(line) next DEPTH
** all the work is done here
** nonprocedural list is 20% faster than procedural do-while loop
** and there is another 20% improvement when you trim line
if foundit > 0
saverec = min(recno(), reccount() - 1)
goto foundit
set color to N/W+
@START,1 say trim(line) && why trouble if first few lines?
set color to
goto saverec
foundit = 0
endif
do MSG with iif(pages = 1, "", ;
"Prev, Next, Begin, End, Search, Repeat, #, ") + "File, or Quit? "
ink = 0
do while ink = 0
ink = inkey()
enddo
which = upper(chr(ink))
num = val(which)
if pages = 1
do case
case which = 'F'
do NEW_FILE
case which = 'Q'
do BYE_BYE
return
otherwise
do WAIT_MSG with "Only one page"
do GO_HOME
endcase
else
do case
case which = 'B' .or. ink = HOME
do GO_HOME
case which = 'E' .or. ink = ENDKEY
do GO_END
case which = 'P' .or. ink = UP .or. ink = PGUP
do GO_PREV
case which = 'N' .or. ink = DOWN .or. ink = PGDN
do GO_NEXT
case num > 0 && it's a page number
do GO_PAGE with num
case which = '#' && if can't get to page with 1 digit
do ACCEPTVAR with "Go to page #", whichpage
mypage = val(whichpage)
do GO_PAGE with mypage
case which $ "SR"
if which = 'S'
do ACCEPTVAR with "Search for ", phrase
endif
if which = 'S' .or. (which = 'R' .and. didsearch)
do MSG with "Searching for " + phrase + "..."
endif
saverec = iif(recno() - DEPTH > 1, recno() - DEPTH, 1)
if .not. eof()
goto saverec + 1
endif
if which = 'S'
locate for at(phrase, line) > 0
didsearch = .T.
else if which = 'R'
if didsearch
continue
else
do WAIT_MSG with "Must do SEARCH before REPEAT"
endif
endif
**** replaced do-while loop with locate/continue
if .not. found()
if didsearch
do WAIT_MSG with "Not found"
endif
goto saverec
else
foundit = recno()
skip -1 && back up so they can see it
page = int(((recno() - MYTOP) / DEPTH) + 1)
endif
case which = 'F'
do NEW_FILE
**** you might not want this in your applications:
**** just substitute "do GO_NEXT"
case which = 'Q'
do BYE_BYE
return
otherwise && same as 'N'
do GO_NEXT
endcase
endif
enddo
return
procedure GO_HOME
goto MYTOP
page = 1
return
procedure GO_END
goto end
page = pages
return
procedure GO_PREV
prev = iif(recno() > (DEPTH*2+1), recno()-(DEPTH*2), MYTOP)
goto prev
page = iif(page > 1, page - 1, 1)
return
procedure GO_NEXT
goto iif(eof(), recno() - DEPTH + 1, recno())
page = iif(page < pages - 1, page + 1, pages)
return
procedure GO_PAGE
parameter pg
pg = iif(pg <= 1, 1, int(pg))
goto iif(pg >= pages, end, ((pg - 1) * DEPTH) + MYTOP - iif(pg = 1, 0, 1))
page = iif(pg >= pages, pages, pg)
return
procedure MSG
parameter msg
@msgline,0 clear
@msgline,0 say msg
do BLINKY
return
procedure WAIT_MSG
parameter msg
@msgline,len(msg)+31
do BLINKY
@msgline-1,79
wait msg + " ... Press any key to continue"
@msgline,0
return
procedure ACCEPTVAR
parameters msg, var
@msgline,0
@msgline,len(msg)
do BLINKY
@msgline-1,79
accept msg to temp
var = temp
* var has to be declared PUBLIC
return
procedure BYE_BYE
close databases
call curson
@msgline,0
return
procedure SHOW_REV
parameters msg, row, col
@row,col
@row,col get msg
clear gets
return
procedure NEW_FILE
saverec = iif(recno() - DEPTH > 1, recno() - DEPTH, 1)
do ACCEPTVAR with "New filename to switch to? ", otherfile
if file(otherfile)
* not supposed to do recursion, but...
do MSG with "Switching file..."
* it'll surprise them to see two blinking cursors!
do PAGES with otherfile, MYTOP, DEPTH, START, SHOWPAGE, SHOWRULE
* after recursion, DON'T pick up where we left off...
do BYE_BYE
return to master
else
do WAIT_MSG with "No such file"
goto saverec
endif
return
procedure BLINKY && our own blinking cursor: don't call curson
set color to w*
?? '_'
set color to
return